home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 60.zip / BS1 part 60 / Kick Pascal v2.10 d2.adf / DEMO / Datei.p < prev    next >
Text File  |  1990-11-01  |  13KB  |  485 lines
  1. Program AddrMat;
  2.  
  3. {  Eine kleine Adressdatei.           }
  4. {                                     }
  5. {  Geschrieben von :                  }
  6. {  Jens "Himpel" Gelhar 1989          }
  7. {  als Demo für Himpel-/Kickpascal    }
  8.  
  9. { Dieses Programm demonstriert u. a. die Ein-/Ausgabeoperationen.
  10.   Um die Anwendung der Dateibefehle zu zeigen, wird die Datei
  11.   nicht in den Speicher geladen, sondern ausschließlich auf der
  12.   Disk bearbeitet. Dies schränkt die Möglichkeiten des Programms
  13.   natürlich stark ein.                                            }
  14.  
  15.  
  16. Label Ende1;
  17.   { Labels sollten nur verwendet werden, wenn der "normale"
  18.     Programmablauf unterbrochen wird. Das Label 'Ende1' steht
  19.     kurz vor dem Ende des Hauptprogramms und wird angesprungen,
  20.     wenn bei der Eingabe des Dateinamens ESC gedrückt wird.     }
  21.  
  22.  
  23. Const
  24.   CSI = chr($9b);       { Steuersequenzen-Einleiter }
  25.  
  26.   CrsrUp   = chr(1);    { Da bei Betätigung der Cursortasten            }
  27.   CrsrDown = chr(2);    { ganze Escape-Sequenzen gesendet werden, die   }
  28.   CrsrLeft = chr(3);    { umständlich zu handhaben sind, werden sie     }
  29.   CrsrRigth= chr(4);    { von der GETKEY-Prozedur in diese Codes gewandelt. }
  30.   BackSpace= chr(8);
  31.   LF       = chr(10);
  32.   CR       = chr(13);
  33.   Esc      = chr(27);
  34.   Del      = chr($7f);
  35.  
  36. Type
  37.   Anrede = (Herr, Frau, Firma, Ungueltig);
  38.  
  39.   Person=Record         { der Hauptdatentyp }
  40.            Anr: Anrede;
  41.            VName,NName: String[30]
  42.            Telefon: String[20]
  43.            Strasse: String[30]
  44.            Hausnr:  integer
  45.            Plz:     0..9999
  46.            Ort:     String[12];
  47.          End;
  48.  
  49.   Datei = File of Person;
  50.  
  51.   StrTyp = String;      { Für Parameterübergaben. Denn: "String" ist }
  52.                         { kein Typbezeichner, sondern ein Symbol!    }
  53.  
  54. Var
  55.   fname: StrTyp;        { Dateiname }
  56.   f: Datei;             { die Datei }
  57.   fs: Long;             { Speicher für "filesize(f)" }
  58.   Menu: Char;           { Im Hauptmenü eingegebenes Zeichen }
  59.   Win, Con: Ptr;        { Windowhandle und Console-Device }
  60.   Out: String;          { Ausgabepuffer für "WriteCon" }
  61.  
  62.  
  63. Procedure WriteC(s: Str);
  64.   { String "s" über Console.device ausgeben }
  65.   Begin
  66.     WriteCon(con,s)
  67.   End;
  68.  
  69.  
  70. Procedure SetXY(x,y: integer);
  71.   { GotoXY-Ersatz für ConDevice }
  72.   Var h: String;
  73.   Begin
  74.     h := CSI + IntStr(y) + ';' + intStr(x) + 'H';
  75.     WriteCon(Con,h)
  76.   End;
  77.  
  78.  
  79. Function WaitKey: Char;
  80.   { Auf Tastencode warten und zurückgeben }
  81.   Var c: Char;
  82.       Sig: Long;
  83.   Begin
  84.     Repeat
  85.       c := ReadCon(Con);
  86.       If c = #0 Then Sig := Wait(-1)
  87.     Until c <> chr(0);
  88.     WaitKey := c
  89.   End;
  90.  
  91.  
  92. Function GetKey: Char;
  93.   { Taste lesen und Sequenzen wandeln }
  94.   Var c: Char;
  95.  
  96.     Procedure CSIHandler;
  97.       Var s: String;
  98.       Begin
  99.         s:='';
  100.         Repeat           { Sequenz zeichenweise lesen }
  101.           s:=s+WaitKey
  102.         Until (Length(s)>=50) or ( s[Length(s)] >= '@');
  103.         If s='A' Then GetKey := CrsrUp          Else
  104.         If s='B' Then GetKey := CrsrDown        Else
  105.         If s='C' Then GetKey := CrsrRigth       Else
  106.         If s='D' Then GetKey := CrsrLeft        Else
  107.                       GetKey := chr(0)
  108.       End;
  109.  
  110.   Begin
  111.     c := WaitKey;
  112.     If c in [ chr(32).. chr(126), chr(160)..chr(255) ] Then
  113.       GetKey := c       { druckbares Zeichen }
  114.     Else
  115.       Case c Of
  116.         chr(8):  GetKey := BackSpace;
  117.         chr(13): GetKey := CR;
  118.         chr(27): GetKey := Esc;
  119.         chr($7f):GetKey := Del;
  120.         CSI:     CSIHandler;
  121.       Otherwise
  122.         Getkey := chr(0)
  123.       End;
  124.   End;
  125.  
  126.  
  127. Procedure FindEnd( Var st: StrTyp, i: integer);
  128.   { Ende von s[1] .. s[i] suchen, mit Nullbyte markieren }
  129.   Begin
  130.     While (i>1) and (st[i]=' ') Do
  131.       i:=pred(i);
  132.     st[ i + ord(st[i]<>' ') ] := chr(0)
  133.   End;
  134.  
  135.  
  136. Function LinEd( Var s: Strtyp, x0,y0,max: integer, Var x: integer): Char;
  137.   { String "s" mit der Höchstlänge "max" an Position (x0,y0) edieren. }
  138.   { x: Cursorposition innerhalb Zeile. }
  139.   { zurückgeben: letztes eingegebenes Zeichen (CR, Esc oder Up/Down }
  140.   Var i: integer;
  141.       c: Char;
  142.       ende: Boolean;
  143.   Begin
  144.     SetXY(x0, y0);      { an angegebener Position... }
  145.     writec(s);          { String ausgeben und...     }
  146.     writec(#e'K');      { Rest der Zeile löschen.    }
  147.     For i:=Length(s)+1 to max Do
  148.       s[i]:=' ';        { String mit Spaces auffüllen }
  149.     s[max+1] := chr(0); { ...und mit Nullbyte abschließen. }
  150.     SetXY(x0+x-1, y0);
  151.     ende := false;
  152.  
  153.     Repeat              { Zeileneditor-Hauptschleife }
  154.       c := GetKey;
  155.       If c in [chr(32)..chr(126), chr(160)..chr(255) ] Then
  156.         If x < max Then
  157.           Begin
  158.             For i:=max DownTo x+1 do    { Platz machen }
  159.               s[i] := s[i-1];
  160.             s[x] := c;                  { und Zeichen einfügen. }
  161.             x := x+1;
  162.             writecon(con, #e'@');       { Ein Zeichen auf Bildschirm einfügen }
  163.             writecon(con, c)            { und Zeichen ausgeben. }
  164.           End
  165.         Else
  166.       Else      { kein darstellbares Zeichen }
  167.         Case c Of
  168.          CR, Esc, CrsrUp, CrsrDown:     { mit diesen Tasten wird der }
  169.                    Ende := true;        { Editor verlassen.          }
  170.          BackSpace:If x>1 Then
  171.                       Begin
  172.                         x:=pred(x);
  173.                         For i:=x to max-1 do s[i] := s[i+1];
  174.                         s[max]:=' ';
  175.                         writecon(con, #8\e'P')
  176.                       End;
  177.          CrsrLeft: If x>1 Then
  178.                       Begin
  179.                         x := pred(x);
  180.                         writecon(con, #e'D')
  181.                       End;
  182.          CrsrRigth: If x<max Then
  183.                       Begin
  184.                         x := succ(x);
  185.                         writecon(con, #e'C')
  186.                       End;
  187.          Del:       Begin
  188.                       For i:=x to max-1 do s[i] := s[i+1];
  189.                       s[max]:=' ';
  190.                       writecon(con, #e'P')
  191.                     End;
  192.         Otherwise End;
  193.  
  194.     Until ende;
  195.  
  196.     FindEnd( s , max);  { Spaces am zeilenende abschneiden }
  197.     LinEd := c          { Zeichen zurückgeben }
  198.   End;
  199.  
  200.  
  201. Procedure Ausgabe1(p: Person);
  202.   { mit Feldnamen ausgeben }
  203.   Var s:String;
  204.   Begin
  205.     With p do
  206.       Begin
  207.         WriteC('Anrede: (HFG)  ');
  208.           Case Anr Of
  209.             Herr: WriteC("Herr");
  210.             Frau: WriteC("Frau");
  211.             Firma: WriteC("Firma")
  212.           Otherwise End;
  213.         WriteC(#e'K'\10'Vorname:       '); If Anr<>Firma Then WriteC(VName);
  214.         WriteC(#e'K'\10'Nachname:      '); writeC(NName);
  215.         WriteC(#e'K'\10'Telefon:       '); writeC(Telefon);
  216.         WriteC(#e'K'\10'Strasse:       '); writeC(Strasse);
  217.         WriteC(#e'K'\10'Nr.:           '); s := IntStr(HausNr); If HausNr>=0 Then writeC(s);
  218.         WriteC(#e'K'\10'Plz.:          '); s := IntStr(Plz); If plz<>0 Then writeC(s);
  219.         WriteC(#e'K'\10'Ort:           '); writeC(Ort);
  220.       End
  221.   End;
  222.  
  223.  
  224. Procedure Edit(Var p:Person);
  225.   Var buf: String;
  226.       Zeile: integer;
  227.       z,s,m: integer;
  228.       c: Char;
  229.   Begin
  230.     SetXY(1,4);
  231.     Ausgabe1(p);
  232.     Zeile:=1;
  233.  
  234.     Repeat
  235.       If Zeile=1 Then
  236.         Repeat
  237.           SetXY(16,4);
  238.           Case p.Anr Of
  239.             Herr:  writeC("Herr");
  240.             Frau:  writeC("Frau");
  241.             Firma: writeC("Firma");
  242.             Otherwise
  243.           End;
  244.           writeC(#e"K");
  245.  
  246.           Repeat
  247.             c:=GetKey
  248.           Until Upcase(c) in ["H","F","G",CR,CrsrUp,CrsrDown,Esc];
  249.  
  250.           Case Upcase(c) Of
  251.            "H": p.Anr := Herr;
  252.            "F": p.Anr := Frau;
  253.            "G": p.Anr := Firma;
  254.            Otherwise;
  255.           End;
  256.  
  257.         Until (c in [CR, CrsrUp, CrsrDown, Esc]) and (p.Anr<>Ungueltig)
  258.       Else
  259.       If (Zeile=2) and (p.Anr=Firma) Then
  260.         Begin p.VName :=""; SetXY(16,5); writeC(#e'K') End
  261.       Else
  262.         Begin
  263.           With p Do
  264.             Case Zeile Of
  265.             2: Begin z:=29; buf:=VName End;
  266.             3: Begin z:=29; buf:=NName End;
  267.             4: Begin z:=19; buf:=Telefon End;
  268.             5: Begin z:=29; buf:=Strasse End;
  269.             6: Begin z:=20;
  270.                      If HausNr<0 Then buf:='' Else buf:=IntStr(HausNr) End;
  271.             7: Begin z:=20;
  272.                      If Plz<=0 Then buf:='' Else buf:=IntStr(plz) End;
  273.             8: Begin z:=11; buf:=Ort End;
  274.             End;
  275.           s:=1;
  276.           Repeat
  277.             c:=LinEd(buf,16,Zeile+3,z,s);
  278.             If (Zeile=6) and (buf<>'') Then
  279.               Begin
  280.                 Val(buf,p.HausNr,m);
  281.                 If (m<>0) or (p.HausNr<0) Then c:=" "
  282.               End;
  283.             If (Zeile=7) and (buf<>'') Then
  284.               Begin
  285.                 Val(buf,p.Plz,m);
  286.                 If (m<>0) or (p.Plz<1000) or (p.Plz>9999) Then c:=" "
  287.               End;
  288.           Until c in [CR, CrsrUp, CrsrDown, Esc];
  289.           With p Do
  290.             Case Zeile Of
  291.             2: VName:=buf;
  292.             3: Nname:=buf;
  293.             4: Telefon:=buf;
  294.             5: Strasse:=buf;
  295.             8: Ort:=buf
  296.             Else
  297.             End;
  298.         End;
  299.       If c in [cr, CrsrDown] Then Zeile:=Zeile+1
  300.       Else
  301.         If c=CrsrUp Then Zeile:=Zeile-1;
  302.     Until (Zeile=9) or (Zeile=0) or (c=Esc);
  303.     writeC(LF)
  304.   End;
  305.  
  306.  
  307. Procedure Eingabe(Var p: Person);
  308.   Begin
  309.     WriteC(#12#10'Bitte Daten eingeben!'#10#10);
  310.     With p do
  311.       Begin
  312.         Anr := UnGueltig;
  313.         VName := "";
  314.         NName := "";
  315.         Telefon := "";
  316.         Strasse := "";
  317.         HausNr := -1;
  318.         Plz := 0;
  319.         Ort := "";
  320.       End;
  321.     Edit(p)
  322.   End;
  323.  
  324.  
  325. Procedure Ausgabe(p: Person);
  326.   Var s: string[1000];
  327.   Begin
  328.     With p DO
  329.       Begin
  330.         Case Anr of
  331.           Herr: s := 'Herr '+VName
  332.           Frau: s := 'Frau '+VName
  333.           Firma:s := 'Firma '
  334.         Otherwise
  335.           error('Datenfehler!!');
  336.         End;
  337.        s := LF + s + " " + NName + LF + 'Tel. ' + Telefon + LF + Strasse
  338.                + ' ' + IntStr(HausNR) + LF + IntStr(plz) + ' ' + Ort;
  339.        writecon(con,s);
  340.       End
  341.   End;
  342.  
  343.  
  344. Procedure Ergänzen;
  345.   Var per: Person;
  346.   Begin
  347.     If Filepos(f)<>Filesize(f) Then
  348.       Seek(f,Filesize(f));
  349.     Eingabe(Per);
  350.     write(f,Per)
  351.   End;
  352.  
  353. Procedure Blättern;
  354.   Var per: Person;
  355.       i: Long;
  356.       c: Char;
  357.   Begin
  358.     i := 0;
  359.     Repeat
  360.       writeC(LF);
  361.       Seek(f,i);
  362.       read(f,per);
  363.       Out := #12#10"Datensatz Nr. " + IntStr(i+1);
  364.       If eof(f) Then Out := Out + " - Dateiende";
  365.       Out := Out + LF + LF;
  366.       WriteC(Out);
  367.       Ausgabe1(per);
  368.       writeC(#10\10'SPACE=weiter BACKSPACE=zurück RETURN=Edit ESC=Ende : ');
  369.       Repeat
  370.         c := GetKey
  371.       Until c in [" ",Esc,BackSpace,CR];
  372.       Case c Of
  373.        " ":       If i<filesize(f) Then i:=i+1;
  374.        BackSpace: If i>0 Then i:=i-1;
  375.        CR:        Begin SetXY(1,2); WriteC("Edit"\e"K"); Edit(per);
  376.                         Seek(f,i); write(f,per)
  377.                   End;
  378.       Otherwise
  379.       End;
  380.     Until (c=Esc) or (i=Filesize(f))
  381.   End;
  382.  
  383.  
  384. Procedure DateiAusgeben;
  385.   Var p1,p2: Person; c:Char; i: integer;
  386.   Begin
  387.     Seek(f,0);
  388.     While not eof(f) Do
  389.       Begin
  390.         read(f,p1);    { get(f); p1:=f^ }
  391.         Ausgabe(p1);
  392.         i:=i+1;
  393.         writecon(con,LF)
  394.       End;
  395.     writecon(con,#10'Bitte Taste drücken!  ');
  396.     While ReadCon(con)<>chr(0) do ;   { "Tastenpuffer" leeren }
  397.     c := GetKey
  398.   End;
  399.  
  400.  
  401. Procedure Dateiname;
  402.   Var c: Char;
  403.       L: integer;
  404.       x: integer;
  405.       OK: Boolean;
  406.   Begin
  407.     Repeat
  408.       x := 1;
  409.       fname := '';
  410.       SetXY(1,2);
  411.       writecon(con,'Dateiname: ');
  412.       Repeat
  413.         c:=LinEd(fname,12,2,60,x)
  414.       Until ((fname<>'') and (c=CR)) or (c=Esc);
  415.       If c=Esc Then Goto Ende1;
  416.       WriteCon(con,LF);
  417.       L := Length(fname);
  418.       If L > 4 Then
  419.         If fname[L-3]<>'.' Then
  420.           fname:=fname+'.dat';
  421.       reset(f,fname);
  422.       If IOResult=0 Then
  423.         Exit
  424.       Else
  425.         Begin
  426.           Out := (LF+LF+'Datei '+fname+' existiert nicht.'$a$a'Anlegen? ');
  427.           WriteCon(Con, Out);
  428.           Repeat
  429.             c := GetKey
  430.           Until c in ["J","j","N","n"];
  431.           If Upcase(c)="J" Then
  432.             Begin
  433.               Rewrite(f,fname);
  434.               If IOResult<>0 Then
  435.                  WriteCon(Con, #$0a$0a'Datei konnte nicht angelegt werden.')
  436.               Else
  437.                 Begin
  438.                   Close(f);
  439.                   Reset(f,fname);
  440.                   Exit
  441.                 End
  442.             End
  443.         End
  444.     Until false
  445.   End;
  446.  
  447.  
  448.  
  449. Begin  { Main }
  450.   Win:=Open_Window(0,0,640,200,1,0,$1006,'Himpels very special Database',Nil,640,200,640,255);
  451.   Con:=OpenConsole(Win);
  452.   Dateiname;
  453.   Repeat
  454.     fs := Filesize(f);
  455.     WriteCon(con,chr(12));    { Bildschirm löschen }
  456.     Case fs of
  457.       0: writecon(con, 'Datei ist leer.');
  458.       1: writecon(con, 'Datei enthält einen Datensatz');
  459.     Otherwise
  460.       Out:='Datei enthält '+IntStr(fs)+' Datensätze';
  461.       writecon(con, Out)
  462.     End;
  463.     writecon(con,''\10\10\&
  464.          \e'33mA'\e'31m  Daten hinzufügen'\10\&
  465.          \e'33mB'\e'31m  Blättern'\10\&
  466.          \e'33mL'\e'31m  Adressliste ausgeben'\10\&
  467.          \e'33mQ'\e'31m  Programmende'\10\10'--> ');
  468.  
  469.     Menu:=GetKey;
  470.  
  471.     Case Upcase(Menu) Of
  472.       'A': Ergänzen;
  473.       'B': Blättern;
  474.       'L': DateiAusgeben;
  475.     Otherwise ;
  476.     End;
  477.   Until Upcase(Menu) = 'Q';
  478.   writecon(con,#10#10'Tschüß!');
  479.   Close(f);
  480. Ende1:
  481.   CloseConsole(Con);
  482.   Close_Window(Win);
  483. End.
  484.  
  485.